home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 19 / CD_ASCQ_19_010295.iso / dos / prg / pas / swag / screen.swg / 0051_Best Fade.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  6KB  |  185 lines
  1.  
  2. {
  3. Here is some fade code.   It works in graphics mode as well as text mode. I
  4. have tested it in 80x25 color text mode and 320 x 200 x 256 color graphics
  5. mode (Standard VGA)   The Fade unit is followed by example test program that
  6. shows fading in text mode.   If anyone wants a example for fading in graphics
  7. mode, E-MAIL me.   The only thing I ask you for using this code is that you
  8. E-MAIL me to tell me what you are using it in.   (Well, maybe you could give
  9. me a little credit in the documentation of your program) I didn't write the
  10. SetPalette and GetPalette routines so I don't know what the commented out
  11. CLIs and STIs are for.
  12. My E-MAIL address is ericbrodsky@pslc.psl.wisc.edu
  13. {------------------------------------------------------------------------}
  14. {$R-} {Range checking off (Helps the fade speed)}
  15. {$G+} {286 instructions must be enabled}
  16. unit Fade;
  17.  
  18.     interface
  19.  
  20.  type
  21.      TColor =
  22.   record
  23.       R, G, B: byte;
  24.   end;
  25.      TPalette = array [0..255] of TColor;
  26.      Proc = procedure; {Passed to fade procedures}
  27.  
  28.  procedure SetPalette(Pal: TPalette; First, Last: word);
  29.  procedure GetPalette(var Pal: TPalette; First, Last: word);
  30.  procedure BlackenPalette(First, Last: word);
  31.    {Blackens all colors from First to Last.   Make sure you have the}
  32.    {palette saved in a variable.}
  33.  procedure FadeIn(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
  34. pointer);
  35.    {AProc is called each palette step}
  36.  procedure FadeOut(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
  37. pointer);
  38.    {AProc is called each palette step}
  39.  
  40.     implementation
  41.  
  42.  procedure SetPalette(Pal: TPalette; First, Last: word); assembler;
  43.      asm
  44.   MOV   DX, 03DAh
  45.        @Rt:
  46.   IN    AL, DX       { wait for no retrace                 }
  47.   TEST  AL, 8        { this bit is high during a retrace   }
  48.   JZ    @Rt          { so loop until it goes high          }
  49.  
  50.   MOV   CX, [Last]   { CX = last colour to set             }
  51.   MOV   AX, [First]  { AX = first colour to set            }
  52.   SUB   CX, AX
  53.   INC   CX           { CX = number of colours to set       }
  54.   MOV   DX, 03C8h    { Palette Address register            }
  55.   {CLI}
  56.   OUT   DX, AL       { set starting register               }
  57.   INC   DX           { Palette Data register               }
  58.   PUSH  DS
  59.   LDS   SI, [Pal]    { DS:SI -> palette                    }
  60.   ADD   SI, AX
  61.   ADD   SI, AX
  62.   ADD   SI, AX       { DS:SI -> first entry to set         }
  63.   MOV   AX, CX       { triple the value in CX              }
  64.   ADD   CX, AX
  65.   ADD   CX, AX       { CX = total number of bytes to write }
  66.   REP   OUTSB        { write palette                       }
  67.   {STI}
  68.   POP   DS
  69.      end;
  70.  
  71.  procedure GetPalette(var Pal: TPalette; First, Last: word); assembler;
  72.      asm
  73.     MOV   CX, [Last]     { CX = last colour                    }
  74.     MOV   AX, [First]    { AX = starting colour                }
  75.     SUB   CX, AX
  76.     INC   CX             { CX = number of colours              }
  77.     MOV   DX, 03C7h      { Palette Address register            }
  78.     {CLI}
  79.     OUT   DX, AL         { set starting register               }
  80.     INC   DX
  81.     INC   DX             { DX = Palette Data register          }
  82.     LES   DI, [Pal]      { ES:DI -> palette                    }
  83.     ADD   DI, AX
  84.     ADD   DI, AX
  85.     ADD   DI, AX         { ES:DI -> first entry to read        }
  86.     MOV   AX, CX         { triple the value in CX              }
  87.     ADD   CX, AX
  88.     ADD   CX, AX         { CX = total number of bytes to read  }
  89.     REP   INSB           { Read  palette                       }
  90.     {STI}
  91.      end;
  92.  
  93.  procedure BlackenPalette(First, Last: word);
  94.      var
  95.   Pal: TPalette;
  96.   i: word;
  97.      begin
  98.   for i := First to Last do
  99.       begin
  100.    Pal[i].R := 0; Pal[i].G := 0; Pal[i].B := 0;
  101.       end;
  102.   SetPalette(Pal, First, Last);
  103.      end;
  104.  
  105.  procedure FadeIn(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
  106. pointer);
  107.      var
  108.   i, j    : Byte;
  109.   TempPal : TPalette;
  110.      begin
  111.   for i := 0 to Speed do
  112.       begin
  113.    for j := First to Last do
  114.        begin
  115.     TempPal[j].R := Pal[j].R * i div Speed;
  116.     TempPal[j].G := Pal[j].G * i div Speed;
  117.     TempPal[j].B := Pal[j].B * i div Speed;
  118.        end;
  119.    Setpalette(TempPal, First, Last);
  120.    if (AProc <> nil) then Proc(AProc);
  121.       end;
  122.      end;
  123.  
  124.  procedure FadeOut(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
  125. pointer);
  126.      var
  127.   i, j    : Byte;
  128.   TempPal : TPalette;
  129.      begin
  130.   TempPal := Pal;
  131.   for i := Speed downto 0 do
  132.       begin
  133.    for j := First to Last do
  134.        begin
  135.     TempPal[j].R := Pal[j].R * i div Speed;
  136.     TempPal[j].G := Pal[j].G * i div Speed;
  137.     TempPal[j].B := Pal[j].B * i div Speed;
  138.        end;
  139.    Setpalette(TempPal, First, Last);
  140.    if (AProc <> nil) then Proc(AProc);
  141.       end;
  142.      end;
  143.     end.
  144.  
  145. {---------------------------------------------------------------------}
  146.  
  147. program FadeTest;
  148.     uses
  149.  CRT,
  150.  Fade;
  151.     const
  152.  FadeSpeed1 = 64;
  153.  
  154.  FadeSpeed2 = 64;
  155.     var
  156.  Pal : TPalette;
  157.  i : longint;
  158.     procedure aProcedure; far;
  159.       {This procedure will be called every fade step}
  160.  begin
  161.      Inc(i);
  162.      writeln('Test 2 of Ethan Brodsky''s fade routines:   Fade Step #',
  163.                     i);
  164.  end;
  165.     begin
  166.  GetPalette(Pal, 0, 255);
  167.  
  168.  {Test part 1}
  169.  BlackenPalette(0, 255);
  170.  writeln('Test 1 of Ethan Brodsky''s fade routines');
  171.  FadeIn(Pal, 0, 255, FadeSpeed1, nil);
  172.  FadeOut(Pal, 0, 255, FadeSpeed1, nil);
  173.  FadeIn(Pal, 0, 255, FadeSpeed1, nil);
  174.  
  175.  writeln('Press any key to continue . . .');
  176.  repeat until KeyPressed;
  177.  
  178.  {Test part 2}
  179.  i := 0;
  180.  FadeOut(Pal, 0, 255, FadeSpeed2, @aProcedure);
  181.  i := 0;
  182.  FadeIn(Pal,  0, 255, FadeSpeed2, @aProcedure);
  183.     end.
  184.  
  185.